home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / scope / 026-050 / scopedisk31 / doodle / doodle.bas (.txt) < prev    next >
AmigaBASIC Source Code  |  1995-03-18  |  19KB  |  962 lines
  1. '  Doodle by Allen Wadle September 25, 1988
  2. '            1905 Lanette
  3. '            Arlington, Tx 76010
  4. '            817-649-0262
  5.  
  6.   ON ERROR GOTO WrapUp
  7.  
  8.   DEFINT a-z
  9.   
  10.   BaseDir$ = "DF1:Doodle": BasicBMAP$ = "DF1:BasicBMAPS"
  11.  
  12.   GOSUB Init.Libs
  13.   GOSUB InitConstant
  14.   GOSUB InitMenu
  15.   GOSUB InitFile
  16.  
  17.   ON MENU GOSUB CheckMenu : MENU ON
  18.   ON MOUSE GOSUB CheckMouse : MOUSE ON
  19.   ON BREAK GOSUB IgnoreBreak: BREAK ON
  20.   Unfinished = -1: BEEP
  21.  
  22.   WHILE Unfinished
  23.     SLEEP 'this program is completely event driven
  24.   WEND
  25.  
  26. WrapUp:
  27.   MENU OFF: MOUSE OFF
  28.   SCREEN CLOSE 1
  29.   WINDOW CLOSE 1
  30.   WINDOW 1,,,,-1
  31.  
  32.   MENU RESET
  33.   CLS
  34.   ON ERROR GOTO 0
  35.   END
  36.  
  37. InitConstant:
  38.   depth=3: xmin=0: ymin=0: xmax=640: ymax=200
  39.   smax=10000: DIM RegionArray%(smax/2)  'alloc 10k bytes for cut/paste
  40.   MaxTool=8: DIM ToolName$(MaxTool)
  41.   MaxReg=4:  DIM RegionTool$(MaxReg)
  42.   CurrentColor=1
  43.   MaxColor = 2^depth - 1: DIM ColorName$(MaxColor)
  44.   SCREEN 1,xmax,ymax,depth,2
  45.   WINDOW 1,"Doodle by Allen Wadle",,21,1
  46.   ColorName$(0)="  white   ": PALETTE 0,1,1,1
  47.   ColorName$(1)="  blue    ": PALETTE 1,0,0.3,0.6
  48.   ColorName$(2)="  black   ": PALETTE 2,0,0,0.1
  49.   ColorName$(3)="  orange  ": PALETTE 3,1,0.5,0
  50.   ColorName$(4)="  red     ": PALETTE 4,0.93,0.2,0    
  51.   ColorName$(5)="  yellow  ": PALETTE 5,1,1,0.13     
  52.   ColorName$(6)="  green   ": PALETTE 6,0.33,0.87,0    
  53.   ColorName$(7)="  gray    ": PALETTE 7,0.73,0.73,0.73  
  54.  
  55.   MaxFont=3: DIM FontName$(MaxFont), FontSize&(MaxFont)
  56.   FontName$(0)="topaz"   : FontSize&(0)=11
  57.   FontName$(1)="ruby"    : FontSize&(1)=15
  58.   FontName$(2)="garnet"  : FontSize&(2)=16
  59.   FontName$(3)="sapphire": FontSize&(3)=19
  60.   
  61.   RETURN
  62.  
  63. InitFile:
  64.   CALL Interact("Name for picture?",FileName$)
  65.     WINDOW CLOSE 1: WINDOW 1,FileName$,,21,1
  66.   CurrentX=640:CurrentY=200
  67.   menuitem=1: GOSUB ToolsMenu: menuitem=2: GOSUB ColorMenu
  68.   menuitem=3: GOSUB FontMenu
  69.   menuitem=0: GOSUB RegionMenu
  70.   RETURN
  71.  
  72. InitMenu:
  73.  
  74.   MENU 1,0,1,"File"
  75.   MENU 1,1,1,"Directory"
  76.   MENU 1,2,1,"Clear"
  77.   MENU 1,3,1,"Print"
  78.   MENU 1,4,1,"Save"
  79.   MENU 1,5,1,"Load"
  80.   MENU 1,6,1,"Quit"
  81.  
  82.   MENU 2,0,1,"Tools" 
  83.   ToolName$(1)="Pen      "
  84.   ToolName$(2)="Line     "
  85.   ToolName$(3)="Oval     "
  86.   ToolName$(4)="Rectangle"
  87.   ToolName$(5)="Diamond  "
  88.   ToolName$(6)="Text     "
  89.   ToolName$(7)="Eraser   "
  90.   ToolName$(8)="Paint    "
  91.   FOR i=1 TO MaxTool: MENU 2,i,1,"  "+ToolName$(i): NEXT
  92.  
  93.   MENU 3,0,1,"Colors"
  94.   FOR i=0 TO MaxColor: MENU 3,i+1,1,ColorName$(i): NEXT
  95.  
  96.   MENU 4,0,1,"Fonts"
  97.   FOR i=0 TO MaxFont: MENU 4,i+1,1,"  "+FontName$(i): NEXT
  98.  
  99.   MENU 5,0,1,"Region"
  100.   RegionTool$(1)="Clear Reg"
  101.   RegionTool$(2)="Memorize "
  102.   RegionTool$(3)="Paste    "
  103.   RegionTool$(4)="Combine  "
  104.   FOR i=1 TO MaxReg: MENU 5,i,1,"  "+RegionTool$(i): NEXT
  105.  
  106.   MENU 6,0,1,""
  107.   RETURN
  108.  
  109. CheckMenu:
  110.   MenuId=MENU(0)
  111.   menuitem=MENU(1)
  112.   ON MenuId GOTO FileMenu,ToolsMenu,ColorMenu,FontMenu,RegionMenu
  113.   
  114. CheckMouse:
  115.   GetCurrentXY 
  116.   StartY=CurrentY
  117.   StartX=CurrentX
  118.   IF RegionMode<>0 THEN
  119.     ON RegionMode GOSUB ClearRegion,MemorizeRegion,PasteRegion,PasteRegion
  120.   ELSE
  121.     ON ToolMode GOSUB Pen,DoLine,DoCircle,DoRectangle,DoDiamond,DoText,DoErase,DoPaint
  122.   END IF
  123.   RETURN
  124.  
  125. DoText:
  126.   WHILE MOUSE(0)<>0
  127.     GetCurrentXY
  128.     col = 1 + CurrentX/8
  129.     row = 1 + CurrentY/8
  130.     InvertVideo
  131.     LOCATE row,col: PRINT "?";
  132.     LOCATE row,col: PRINT "?";
  133.     NormalVideo
  134.   WEND
  135.   COLOR CurrentColor
  136.   BEEP: LOCATE row,col
  137.   CALL DiskFont( FontName$(Fontnum), FontSize&(Fontnum) )  
  138. GetText:
  139.   a$=INKEY$
  140.   IF a$<>CHR$(13) THEN 
  141.     PRINT a$;
  142.     GOTO GetText
  143.   END IF
  144.   CALL DiskFont( "topaz", 8 )
  145.   RETURN
  146.  
  147. DoLine:
  148.   WHILE MOUSE(0)<>0
  149.     GetCurrentXY
  150.     InvertVideo
  151.     LINE (StartX,StartY)-(CurrentX,CurrentY) 'draw line
  152.     LINE (StartX,StartY)-(CurrentX,CurrentY) 'erase line
  153.     NormalVideo
  154.   WEND
  155.   LINE (StartX,StartY)-(CurrentX,CurrentY),CurrentColor
  156.   RETURN
  157.   
  158. Pen:
  159.   GetCurrentXY
  160.   PSET (CurrentX,CurrentY),CurrentColor
  161.   WHILE MOUSE(0)<>0
  162.     GetCurrentXY
  163.     LINE -(CurrentX,CurrentY),CurrentColor
  164.   WEND
  165.   RETURN
  166.  
  167. DoCircle:
  168.   WHILE MOUSE(0)<>0
  169.     GetCurrentXY
  170.     CenterX=(StartX+CurrentX)/2
  171.     CenterY=(CurrentY+StartY)/2
  172.     RadiusX=ABS(CurrentX-StartX)/2: IF RadiusX=0 THEN RadiusX=1
  173.     RadiusY=ABS(CurrentY-StartY)/2: IF RadiusY=0 THEN RadiusY=1
  174.     Aspect!=ABS(RadiusY/RadiusX)
  175.     IF RadiusX < RadiusY THEN RadiusX=RadiusY
  176.     InvertVideo
  177.     FOR i = 1 TO 2
  178.       CIRCLE (CenterX,CenterY),RadiusX,CurrentColor,,,Aspect!
  179.     NEXT
  180.     NormalVideo
  181.   WEND
  182.   CIRCLE (CenterX,CenterY),RadiusX,CurrentColor,,,Aspect!
  183.   RETURN
  184.  
  185. DoRectangle:
  186.   WHILE MOUSE(0)<>0
  187.     GetCurrentXY
  188.     InvertVideo
  189.     FOR i = 1 TO 2
  190.       LINE (StartX,StartY)-(CurrentX,CurrentY),CurrentColor,b
  191.     NEXT
  192.     NormalVideo
  193.   WEND
  194.   LINE (StartX,StartY)-(CurrentX,CurrentY),CurrentColor,b
  195.   RETURN
  196.  
  197. DoDiamond:
  198.   WHILE MOUSE(0)<>0
  199.     GetCurrentXY
  200.     CenterX=(StartX+CurrentX)/2
  201.     CenterY=(CurrentY+StartY)/2
  202.     InvertVideo
  203.        FOR i = 1 TO 2
  204.          LINE (CenterX,StartY)-(CurrentX,CenterY),CurrentColor
  205.          LINE (CurrentX,CenterY)-(CenterX,CurrentY),CurrentColor
  206.          LINE (CenterX,CurrentY)-(StartX,CenterY),CurrentColor
  207.          LINE (StartX,CenterY)-(CenterX,StartY),CurrentColor
  208.        NEXT
  209.     NormalVideo
  210.   WEND
  211.   LINE (CenterX,StartY)-(CurrentX,CenterY),CurrentColor
  212.   LINE (CurrentX,CenterY)-(CenterX,CurrentY),CurrentColor
  213.   LINE (CenterX,CurrentY)-(StartX,CenterY),CurrentColor
  214.   LINE (StartX,CenterY)-(CenterX,StartY),CurrentColor
  215.   RETURN
  216.  
  217. DoErase:
  218.   WHILE MOUSE(0)<>0
  219.     GetCurrentXY
  220.     LINE (CurrentX-5,CurrentY-3)-(CurrentX,CurrentY),1,bf
  221.     LINE (CurrentX-5,CurrentY-3)-(CurrentX,CurrentY),0,bf
  222.   WEND
  223.   RETURN
  224.  
  225. DoPaint:
  226.    PAINT (CurrentX, CurrentY),CurrentColor
  227.    ToolMode=OldTool: GOSUB ShowTool
  228.    RETURN
  229.  
  230. ToolsMenu:
  231.   OldTool=ToolMode: ToolMode=menuitem: RegionMode=0
  232.  
  233. ShowTool:
  234.   FOR i=1 TO MaxTool: MENU 2,i,1: NEXT
  235.   FOR i=1 TO MaxReg:  MENU 5,i,1: NEXT
  236.   IF RegionMode=0 THEN
  237.     MENU 2,ToolMode,2
  238.     LOCATE 1,16: COLOR 1: PRINT ToolName$(ToolMode);
  239.   ELSE
  240.     MENU 5,RegionMode,2
  241.     LOCATE 1,16: COLOR 1: PRINT RegionTool$(RegionMode)
  242.   END IF
  243.   RETURN
  244.  
  245. FontMenu:
  246.   Fontnum=menuitem-1
  247.   FOR i=1 TO MaxFont+1: MENU 4,i,1: NEXT: MENU 4,menuitem,2
  248.   RETURN
  249.  
  250. ColorMenu:
  251.   CurrentColor=menuitem-1
  252.   COLOR CurrentColor
  253.   FOR i=1 TO MaxColor+1: MENU 3,i,1: NEXT: MENU 3,menuitem,2
  254.   ColorBar:
  255.   x=20: dx=10: dy=5: xc=2*dy: yc=dy/2
  256.   CIRCLE (xc,yc),dy,CurrentColor: PAINT (xc,yc)
  257.   FOR i=0 TO MaxColor
  258.     LINE (x,0)-(x+dx,dy),i,bf
  259.     LINE (x,0)-(x+dx,dy),1,b
  260.     x=x+dx
  261.   NEXT i
  262.   RETURN
  263.   
  264. RegionMenu:
  265.   RegionMode = menuitem
  266.   GOSUB ShowTool
  267.   RETURN
  268.  
  269. ClearRegion:
  270.   WHILE MOUSE(0)<>0
  271.     GetCurrentXY
  272.     InvertVideo
  273.     FOR i = 1 TO 2
  274.       LINE (StartX,StartY)-(CurrentX,CurrentY),CurrentColor,b
  275.     NEXT
  276.     NormalVideo
  277.   WEND
  278.   LINE (StartX,StartY)-(CurrentX,CurrentY),0,bf
  279.   RETURN
  280.     
  281. MemorizeRegion:
  282.   WHILE MOUSE(0)<>0
  283.     GetCurrentXY
  284.     EndX=CurrentX
  285.     term=INT((EndX-StartX+16)/16)
  286.     IF term=0 THEN term=1
  287.     EndYmax = (smax-6)/(2*depth*term)+StartY-1
  288.     IF CurrentY<=EndYmax THEN 
  289.       EndY=CurrentY
  290.     ELSE
  291.       EndY=EndYmax
  292.     END IF
  293.     InvertVideo
  294.     FOR i = 1 TO 2
  295.       LINE (StartX,StartY)-(EndX,EndY),CurrentColor,b
  296.     NEXT
  297.     NormalVideo
  298.   WEND
  299.   GET (StartX,StartY)-(EndX,EndY),RegionArray
  300.   delXreg=EndX-StartX: delYreg=EndY-StartY
  301.   menuitem=0: GOSUB RegionMenu
  302.   BEEP
  303.   RETURN
  304.   
  305. PasteRegion:
  306.   WHILE MOUSE(0)<>0
  307.     GetCurrentXY
  308.     EndX=CurrentX+delXreg: EndY=CurrentY+delYreg
  309.     InvertVideo
  310.     FOR i = 1 TO 2
  311.       LINE (CurrentX,CurrentY)-(EndX,EndY),CurrentColor,b
  312.     NEXT
  313.     NormalVideo
  314.   WEND
  315.   IF RegionMode=4 THEN
  316.     PUT (CurrentX,CurrentY),RegionArray,OR
  317.   ELSE  
  318.     PUT (CurrentX,CurrentY),RegionArray,PSET
  319.   END IF
  320.   RETURN
  321.  
  322. FileMenu:
  323.   ON menuitem GOSUB Directory,InitFile,PrintScreen,SaveFile,LoadFile,Quit
  324.   RETURN
  325.  
  326. Directory:
  327.   WINDOW 2,"Directory of "+BaseDir$,,0
  328.   FILES
  329.   INPUT "<< RETURN >>";response$
  330.   WINDOW CLOSE 2: WINDOW 1
  331.   RETURN
  332.   
  333. PrintScreen:
  334.   ScreenDump: BEEP
  335.   RETURN
  336.  
  337. SaveFile:
  338.   CALL Interact( "Save File Name?", FileName$ )
  339.   OPEN FileName$ FOR OUTPUT AS #1: CLOSE #1
  340.   CALL Save.Load.ILBM( "save", FileName$ )
  341.   BEEP
  342.   RETURN
  343.  
  344. LoadFile:
  345.   CALL Interact( "Load File Name?", FileName$ )
  346.   CALL Save.Load.ILBM( "load", FileName$ )
  347.   BEEP
  348.   RETURN
  349.   
  350. Quit:
  351.   Unfinished=0
  352.   RETURN
  353.  
  354. SUB GetCurrentXY STATIC
  355.   SHARED CurrentX,CurrentY
  356.   dummy=MOUSE(0)
  357.   CurrentX=MOUSE(1)
  358.   CurrentY=MOUSE(2)
  359. END SUB
  360.  
  361. SUB InvertVideo STATIC
  362.    CALL SetDrMd& (WINDOW(8),3)
  363. END SUB
  364.  
  365. SUB NormalVideo STATIC
  366.    CALL SetDrMd& (WINDOW(8),1)
  367. END SUB
  368.  
  369. IgnoreBreak:
  370.   RETURN
  371.  
  372.  
  373. '__________________________________________________________________________
  374. '
  375. '    Routines to Save, Load, & Print Amiga Screens & change fonts
  376. '
  377. '    GOSUB Init.Libs
  378. '    CALL Save.Load.ILBM( mode$, filename$ ), where mode$="save"/"load"
  379. '    Call ScreenDump
  380. '    Call DiskFont( fontname$, height& )
  381. '___________________________________________________________________________
  382.  
  383. SUB DiskFont( FontName$, height& ) STATIC
  384.   textAttr&(0)=SADD(FontName$+".font"+CHR$(0))
  385.   textAttr&(1)=height&*65536
  386.   FontPtr&=OpenDiskFont&(VARPTR(textAttr&(0)))
  387.   IF FontPtr& THEN SetFont& WINDOW(8),FontPtr&
  388. END SUB
  389.  
  390.  
  391. SUB Interact( prompt$, response$ ) STATIC
  392.   WINDOW 2,"Interaction Window",,0
  393.   LINE (0,0)-(620,190),1,bf
  394.   LINE (20,10)-(600,180),2,bf
  395.   LINE (40,20)-(580,170),3,bf
  396.   LINE (60,30)-(560,160),0,bf
  397.   LOCATE 10,20: PRINT prompt$;
  398.   LOCATE 12,20: INPUT response$
  399.   WINDOW CLOSE 2: WINDOW 1
  400. END SUB
  401.  
  402. Init.Libs:
  403.   REM - Functions from dos.library                   
  404.   DECLARE FUNCTION xOpen&  LIBRARY
  405.   DECLARE FUNCTION xRead&  LIBRARY
  406.   DECLARE FUNCTION xWrite& LIBRARY
  407.   REM - xClose returns no value
  408.  
  409.   REM - Functions from exec.library
  410.   DECLARE FUNCTION AllocMem&() LIBRARY
  411.   REM - FreeMem returns no value
  412.   DECLARE FUNCTION AllocSignal%() LIBRARY
  413.   DECLARE FUNCTION FindTask&()    LIBRARY
  414.   DECLARE FUNCTION DoIO&()        LIBRARY
  415.   DECLARE FUNCTION OpenDevice&    LIBRARY
  416.  
  417.   REM - Functions from diskfont.library
  418.   DECLARE FUNCTION OpenDiskFont& LIBRARY
  419.  
  420.   CHDIR BasicBMAP$
  421.   LIBRARY "dos.library"
  422.   LIBRARY "exec.library"
  423.   LIBRARY "graphics.library"
  424.   LIBRARY "diskfont.library"
  425.   CHDIR BaseDir$
  426.   RETURN
  427.  
  428. SUB Save.Load.ILBM( mode$,ILBMname$) STATIC
  429.    REM No cycling info here
  430.    ccrtDir%=0
  431.    ccrtStart%=0
  432.    ccrtEnd%=0
  433.    ccrtSecs&=0
  434.    ccrtMics&=0
  435.  
  436.    IF mode$="save" THEN GOSUB SaveILBM
  437.    IF mode$="load" THEN GOSUB LoadILBM
  438.    EXIT SUB
  439.  
  440. SaveILBM:
  441. REM - Saves current window's screen
  442. REM -  as an IFF ILBM file with a
  443. REM -  Graphicraft CCRT cycling chunk.
  444. REM - Requires the following variables
  445. REM -  to have been initialized:
  446. REM -    ILBMname$ (ILBM filespec)
  447. REM - Also, cycling variables
  448. REM -    ccrtDir% (1,-1, or 0 = none)
  449. REM -    ccrtStart% (low cycle reg)
  450. REM -    ccrtEnd%   (high cycle reg)
  451. REM -    ccrtSecs&  (cycle time in seconds)
  452. REM -    ccrtMics&  (cycle time in microseconds)
  453. REM 
  454.  
  455. REM - init variables
  456. F$ = ILBMname$
  457. fHandle& = 0
  458. mybuf& = 0
  459.  
  460. FileName$ = F$ + CHR$(0)
  461. fHandle& = xOpen&(SADD(FileName$),1006)
  462. IF fHandle& = 0 THEN
  463.    saveError$ = "Can't open output file"
  464.    GOTO Scleanup
  465. END IF
  466.  
  467. REM - Alloc ram for work buffers
  468. ClearPublic& = 65537
  469. mybufsize& = 120
  470. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  471. IF mybuf& = 0 THEN
  472.    saveError$ = "Can't alloc buffer"
  473.    GOTO Scleanup
  474. END IF
  475.  
  476. cbuf& = mybuf&
  477.  
  478. REM - Get addresses of screen structures
  479. GOSUB GetScrAddrs
  480.  
  481. zero& = 0
  482. pad%  = 0
  483. Aspect% = &Ha0b
  484.  
  485. REM - Compute chunk sizes
  486. BMHDsize& = 20
  487. CMAPsize& = (2^scrDepth%) * 3
  488. CAMGsize& = 4
  489. CCRTsize& = 14
  490. BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
  491. REM - FORMsize& = Chunk sizes + 8 bytes per Chunk header + "ILBM"
  492. FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
  493.  
  494. REM - Write FORM header
  495. tt$ = "FORM"
  496. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  497. wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
  498. tt$ = "ILBM"
  499. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  500.  
  501. IF wLen& <= 0 THEN
  502.    saveError$ = "Error writing FORM header"
  503.    GOTO Scleanup
  504. END IF   
  505.  
  506. REM - Write out BMHD chunk
  507. tt$ = "BMHD"
  508. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  509. wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
  510. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  511. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  512. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  513. temp% = (256 * scrDepth%)
  514. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  515. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  516. wLen& = xWrite&(fHandle&,VARPTR(Aspect%),2)
  517. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  518. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  519.  
  520. IF wLen& <= 0 THEN
  521.    saveError$ = "Error writing BMHD"
  522.    GOTO Scleanup
  523. END IF   
  524.  
  525. REM - Write CMAP chunk
  526. tt$ = "CMAP"
  527. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  528. wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
  529.  
  530. REM - Build IFF ColorMap
  531. FOR kk = 0 TO nColors% - 1
  532.    regTemp% = PEEKW(colorTab& + (2*kk))
  533.    POKE(cbuf&+(kk*3)),(regTemp% AND &Hf00) / 16
  534.    POKE(cbuf&+(kk*3)+1),(regTemp% AND &Hf0) 
  535.    POKE(cbuf&+(kk*3)+2),(regTemp% AND &Hf) * 16
  536. NEXT
  537.  
  538. wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
  539.  
  540. IF wLen& <= 0 THEN
  541.    saveError$ = "Error writing CMAP"
  542.    GOTO Scleanup
  543. END IF   
  544.  
  545. REM - Write CAMG chunk
  546. tt$ = "CAMG"
  547. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  548. wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
  549. vpModes& = PEEKW(sViewPort& + 32)
  550. wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
  551.  
  552. IF wLen& <= 0 THEN
  553.    saveError$ = "Error writing CAMG"
  554.    GOTO Scleanup
  555. END IF   
  556.  
  557.  
  558. REM - Write CCRT chunk
  559. tt$ = "CCRT"
  560. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  561. wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
  562. wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
  563. temp% = (256*ccrtStart%) + ccrtEnd%
  564. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  565. wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
  566. wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
  567. wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
  568.  
  569. IF wLen& <= 0 THEN
  570.    saveError$ = "Error writing CCRT"
  571.    GOTO Scleanup
  572. END IF   
  573.  
  574.  
  575. REM - Write BODY chunk
  576. tt$ = "BODY"
  577. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  578. wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
  579.  
  580. scrRowBytes% = scrWidth% / 8
  581. FOR rr = 0 TO scrHeight% -1
  582.    FOR pp = 0 TO scrDepth% -1
  583.       scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  584.       wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)   
  585.       IF wLen& <= 0 THEN
  586.          saveError$ = "Error writing BODY"
  587.          GOTO Scleanup
  588.       END IF   
  589.    NEXT
  590. NEXT
  591.  
  592.    
  593. saveError$ = ""
  594.  
  595. Scleanup:
  596. ERASE bPlane&
  597. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  598. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  599. RETURN
  600.  
  601. GetScrAddrs:
  602. REM - Get addresses of screen structures
  603.    sWindow&   = WINDOW(7)
  604.    sScreen&   = PEEKL(sWindow& + 46)
  605.    sViewPort& = sScreen& + 44
  606.    sRastPort& = sScreen& + 84
  607.    sColorMap& = PEEKL(sViewPort& + 4)
  608.    colorTab&  = PEEKL(sColorMap& + 4)
  609.    sBitMap&   = PEEKL(sRastPort& + 4)
  610.  
  611.    REM - Get screen parameters
  612.    scrWidth%  = PEEKW(sScreen& + 12)
  613.    scrHeight% = PEEKW(sScreen& + 14)
  614.    scrDepth%  = PEEK(sBitMap& + 5)
  615.    nColors%   = 2^scrDepth%
  616.  
  617.    DIM bPlane&(scrDepth%-1)
  618.    REM - Get addresses of Bit Planes 
  619.    FOR kk = 0 TO scrDepth% - 1
  620.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  621.    NEXT
  622. RETURN
  623.  
  624.  
  625.  
  626.  
  627. LoadILBM:
  628.  
  629. REM - Requires the following variables
  630. REM - to have been initialized:
  631. REM -    ILBMname$ (IFF filename)
  632.  
  633. REM - init variables
  634. F$ = ILBMname$
  635. fHandle& = 0
  636. mybuf& = 0
  637. foundBMHD = 0
  638. foundCMAP = 0
  639. foundCAMG = 0
  640. foundCCRT = 0
  641. foundBODY = 0
  642.  
  643. REM - From include/libraries/dos.h
  644. REM - MODE_NEWFILE = 1006 
  645. REM - MODE_OLDFILE = 1005
  646.  
  647. FileName$ = F$ + CHR$(0)
  648. fHandle& = xOpen&(SADD(FileName$),1005)
  649. IF fHandle& = 0 THEN
  650.    loadError$ = "Can't open/find pic file"
  651.    GOTO Lcleanup
  652. END IF
  653.  
  654.  
  655. REM - Alloc ram for work buffers
  656. ClearPublic& = 65537
  657. mybufsize& = 360
  658. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  659. IF mybuf& = 0 THEN
  660.    loadError$ = "Can't alloc buffer"
  661.    GOTO Lcleanup
  662. END IF
  663.  
  664. inbuf& = mybuf&
  665. cbuf& = mybuf& + 120
  666. ctab& = mybuf& + 240
  667.  
  668.  
  669. REM - Should read  FORMnnnnILBM
  670. rLen& = xRead&(fHandle&,inbuf&,12)
  671. tt$ = ""
  672. FOR kk = 8 TO 11
  673.    tt% = PEEK(inbuf& + kk)
  674.    tt$ = tt$ + CHR$(tt%)
  675. NEXT
  676.  
  677. IF tt$ <> "ILBM" THEN 
  678.    loadError$ = "Not standard ILBM pic file"
  679.    GOTO Lcleanup
  680. END IF
  681.  
  682. REM - Read ILBM chunks
  683.  
  684. ChunkLoop:
  685. REM - Get Chunk name/length
  686.  rLen& = xRead&(fHandle&,inbuf&,8)
  687.  icLen& = PEEKL(inbuf& + 4)
  688.  tt$ = ""
  689.  FOR kk = 0 TO 3
  690.     tt% = PEEK(inbuf& + kk)
  691.     tt$ = tt$ + CHR$(tt%)
  692.  NEXT   
  693.     
  694. IF tt$ = "BMHD" THEN  'BitMap header 
  695.    foundBMHD = 1
  696.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  697.    iWidth%  = PEEKW(inbuf&)
  698.    iHeight% = PEEKW(inbuf& + 2)
  699.    iDepth%  = PEEK(inbuf& + 8)  
  700.    iCompr%  = PEEK(inbuf& + 10)
  701.    scrWidth%  = PEEKW(inbuf& + 16)
  702.    scrHeight% = PEEKW(inbuf& + 18)
  703.  
  704.    iRowBytes% = iWidth% /8
  705.    scrRowBytes% = scrWidth% / 8
  706.    nColors%  = 2^(iDepth%)
  707.  
  708.    REM - Enough free ram to display ?
  709.    AvailRam& = FRE(-1)
  710.    NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
  711.    IF AvailRam& < NeededRam& THEN
  712.       loadError$ = "Not enough free ram"
  713.       GOTO Lcleanup
  714.    END IF
  715.  
  716.    REM - Get addresses of structures
  717.    GOSUB GetScrAddrs
  718.  
  719.    REM - Black out screen
  720.    REM CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  721.  
  722. ELSEIF tt$ = "CMAP" THEN  'ColorMap
  723.    foundCMAP = 1
  724.    rLen& = xRead&(fHandle&,cbuf&,icLen&)
  725.  
  726.    REM - Build Color Table
  727.    FOR kk = 0 TO nColors% - 1
  728.       red% = PEEK(cbuf&+(kk*3))
  729.       gre% = PEEK(cbuf&+(kk*3)+1)
  730.       blu% = PEEK(cbuf&+(kk*3)+2)
  731.       regTemp% = (red%*16)+(gre%)+(blu%/16)
  732.       POKEW(ctab&+(2*kk)),regTemp%
  733.    NEXT
  734.  
  735.  
  736. ELSEIF tt$ = "CAMG" THEN  'Amiga ViewPort Modes
  737.    foundCAMG = 1
  738.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  739.    camgModes& = PEEKL(inbuf&)
  740.  
  741.  
  742. ELSEIF tt$ = "CCRT" THEN 'Graphicraft color cycle info
  743.    foundCCRT = 1
  744.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  745.    ccrtDir%    = PEEKW(inbuf&)
  746.    ccrtStart%  = PEEK(inbuf& + 2)
  747.    ccrtEnd%    = PEEK(inbuf& + 3)
  748.    ccrtSecs&   = PEEKL(inbuf& + 4)
  749.    ccrtMics&   = PEEKL(inbuf& + 8)
  750.  
  751.  
  752. ELSEIF tt$ = "BODY" THEN  'BitMap 
  753.    foundBODY = 1
  754.   
  755.    IF iCompr% = 0 THEN  'no compression
  756.       FOR rr = 0 TO iHeight% -1
  757.          FOR pp = 0 TO iDepth% -1
  758.             scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  759.             rLen& = xRead&(fHandle&,scrRow&,iRowBytes%)   
  760.          NEXT
  761.       NEXT
  762.  
  763.  
  764.    ELSEIF iCompr% = 1 THEN  'cmpByteRun1
  765.       FOR rr = 0 TO iHeight% -1
  766.          FOR pp = 0 TO iDepth% -1
  767.             scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  768.             bCnt% = 0
  769.             
  770.             WHILE (bCnt% < iRowBytes%)
  771.                rLen& = xRead&(fHandle&,inbuf&,1)
  772.                inCode% = PEEK(inbuf&)
  773.                IF inCode% < 128 THEN
  774.                   rLen& = xRead&(fHandle&,scrRow& + bCnt%, inCode%+1)
  775.                   bCnt% = bCnt% + inCode% + 1
  776.                ELSEIF inCode% > 128 THEN
  777.                   rLen& = xRead&(fHandle&,inbuf&,1)   
  778.                   inByte% = PEEK(inbuf&)
  779.                   FOR kk = bCnt% TO bCnt% + 257 - inCode%
  780.                      POKE(scrRow&+kk),inByte%
  781.                   NEXT   
  782.                   bCnt% = bCnt% + 257 - inCode%
  783.                END IF
  784.             WEND
  785.          NEXT
  786.       NEXT
  787.          
  788.    ELSE
  789.       loadError$ = "Unknown compression algorithm"
  790.       GOTO Lcleanup
  791.    END IF
  792.  
  793.  
  794. ELSE 
  795.    REM - Reading unknown chunk  
  796.    FOR kk = 1 TO icLen&
  797.       rLen& = xRead&(fHandle&,inbuf&,1)
  798.    NEXT
  799.    REM - If odd length, read 1 more byte
  800.    IF (icLen& OR 1) = icLen& THEN 
  801.       rLen& = xRead&(fHandle&,inbuf&,1)
  802.    END IF
  803.       
  804. END IF
  805.  
  806.  
  807. REM - Done if got all chunks 
  808. IF foundBMHD AND foundCMAP AND foundBODY THEN
  809.    GOTO GoodLoad
  810. END IF
  811.  
  812. REM - Good read, get next chunk
  813. IF rLen& > 0 THEN GOTO ChunkLoop
  814.  
  815. IF rLen& < 0 THEN  'Read error
  816.    loadError$ = "Read error"
  817.    GOTO Lcleanup
  818. END IF   
  819.  
  820. REM - rLen& = 0 means EOF
  821. IF (foundBMHD=0) OR (foundBODY=0) OR (foundCMAP=0) THEN
  822.    loadError$ = "Needed ILBM chunks not found"
  823.    GOTO Lcleanup
  824. END IF
  825.  
  826.  
  827. GoodLoad:
  828. loadError$ = ""
  829.  
  830. REM  Load proper Colors
  831. IF foundCMAP THEN 
  832.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  833. END IF
  834.  
  835. Lcleanup:
  836. ERASE bPlane&
  837. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  838. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  839.  
  840. RETURN
  841.  
  842. END SUB
  843.  
  844.  
  845. SUB ScreenDump STATIC
  846.  
  847. REM  Get addresses of the structures
  848.  
  849. sWindow&   = WINDOW(7)
  850. sScreen&   = PEEKL(sWindow& + 46)
  851. sViewPort& = sScreen& + 44
  852. sRastPort& = sScreen& + 84
  853. sColorMap& = PEEKL(sViewPort& + 4)
  854.  
  855. REM  Get Screen width, height, modes 
  856.  
  857. maxWidth%  = PEEKW(sScreen& + 12)
  858. maxHeight% = PEEKW(sScreen& + 14)
  859. viewModes% = PEEKW(sViewPort& + 32)
  860.  
  861. REM Set up parameters for dump command
  862.  
  863. command%  = 11   'Printer command number
  864. srcX% = 0        'Send whole screen
  865. srcY% = 0 
  866. srcWidth%  = maxWidth%
  867. srcHeight% = maxHeight%
  868. destRows& = 0    'Dump will compute
  869. destCols& = 0
  870. special% = &H84  'FullCol | Aspect
  871.  
  872. REM *** CreatePort ***
  873.  
  874. sigBit% =  AllocSignal%(-1)
  875. ClearPublic& = 65537
  876. msgPort& = AllocMem&(40,ClearPublic&)
  877. IF msgPort& = 0 THEN
  878.    CALL Interact( "Can't allocate msgPort", dummy$ )
  879.    GOTO cleanup4
  880. END IF
  881.  
  882.  
  883. POKE(msgPort& + 8), 4 'Type=NT_MSGPORT
  884. POKE(msgPort& + 9), 0 'Priority 0 
  885. portName$ = "MyPrtPort"+CHR$(0)
  886. POKEL(msgPort& + 10), SADD(portName$)
  887. POKE(msgPort& + 14), 0 'Flags
  888. POKE(msgPort& + 15), sigBit%
  889. sigTask& = FindTask&(0)
  890. POKEL(msgPort& + 16), sigTask&
  891.  
  892. CALL AddPort#(msgPort&)  'Add the port 
  893.  
  894.  
  895. REM  *** CreatExtIO ***
  896.  
  897. ioRequest& = AllocMem&(64,ClearPublic&)
  898. IF ioRequest& = 0  THEN
  899.    CALL Interact( "Can't allocate ioRequest", dummy$ )
  900.    GOTO cleanup3
  901. END IF
  902.  
  903. POKE(ioRequest& + 8),5 'Type=NT_MESSAGE
  904. POKE(ioRequest& + 9),0 'Priority 0
  905. POKEL(ioRequest& + 14), msgPort&
  906.  
  907.  
  908. REM  *** Open the Printer Device ***
  909.  
  910. devName$ = "printer.device"+CHR$(0)
  911. pError& = OpenDevice&(SADD(devName$),0,ioRequest&,0)
  912. IF pError& <> 0  THEN
  913.    CALL Interact( "Can't open printer", dummy$ )
  914.    GOTO cleanup2
  915. END IF
  916.  
  917.  
  918. REM  *** Dump the RastPort ***
  919.  
  920. POKEW(ioRequest& + 28), command%
  921. POKEL(ioRequest& + 32), sRastPort&
  922. POKEL(ioRequest& + 36), sColorMap&
  923. POKEL(ioRequest& + 40), viewModes%
  924. POKEW(ioRequest& + 44), srcX%
  925. POKEW(ioRequest& + 46), srcY%
  926. POKEW(ioRequest& + 48), srcWidth%
  927. POKEW(ioRequest& + 50), srcHeight%
  928. POKEL(ioRequest& + 52), destCols&
  929. POKEL(ioRequest& + 56), destRows&
  930. POKEW(ioRequest& + 60), special%
  931.  
  932. ioError& = DoIO&(ioRequest&)
  933. IF ioError& <> 0 THEN
  934.    CALL Interact( "DumpRPort error", dummy$ )
  935.    GOTO cleanup1
  936. END IF
  937.  
  938.  
  939. cleanup1:
  940.    REM  *** Close Printer Device ***
  941.    CALL CloseDevice#(ioRequest&)
  942.  
  943. cleanup2:
  944.    REM  *** DeleteExtIO ***
  945.    POKE(ioRequest& + 8), &Hff
  946.    POKEL(ioRequest& + 20), -1
  947.    POKEL(ioRequest& + 24), -1
  948.    CALL FreeMem&(ioRequest&,64)
  949.  
  950. cleanup3:
  951.    REM  *** DeletePort ***
  952.    CALL RemPort#(msgPort&)
  953.    POKE(msgPort& + 8), &Hff  
  954.    POKEL(msgPort& + 20), -1
  955.    CALL FreeSignal#(sigBit%)
  956.    CALL FreeMem&(msgPort&,40)
  957.    
  958. cleanup4:   
  959.  
  960. END SUB   
  961.  
  962.